home *** CD-ROM | disk | FTP | other *** search
/ BBS in a Box 2 / BBS in a box - Trilogy II.iso / Files / Game / R / Rhine / Rhiner < prev   
Encoding:
Text File  |  1993-06-27  |  9.3 KB  |  261 lines  |  [TEXT/McSk]
  1. ( rhine.txt  15 Nov. 1988  10:14 PM )
  2. ( add color, etc  21 July 1991  9:01 PM )
  3. forget task : task ;  0 28 +md !  ( no echo )
  4.  
  5. ( old style colors )
  6. : BLACK    33 0 2>r ,$ A862 ;  ( black _ForeColor )
  7. : WHITE    30 0 2>r ,$ A862 ;  ( white _ForeColor )
  8. : RED     205 0 2>r ,$ A862 ;  ( red _ForeColor )
  9. : GREEN   341 0 2>r ,$ A862 ;  ( green _ForeColor )
  10. : BLUE    409 0 2>r ,$ A862 ;  ( blue _ForeColor )
  11. : CYAN    273 0 2>r ,$ A862 ;  ( blue-green _ForeColor )
  12. : MAGENTA 137 0 2>r ,$ A862 ;  ( purple _ForeColor )
  13. : YELLOW   69 0 2>r ,$ A862 ;  ( yellow _ForeColor )
  14.  
  15. : ?COLOR ( -- f ) ( true if color qd is available )
  16.     ,s qd   ?gestalt IF  drop 256 >  ELSE  0 THEN ;
  17.  
  18. : MYID ( -- id ) ?color IF 150 ELSE 130 THEN ;
  19.  
  20. : 2, ( d -- ) ,$ 24DE ; macro  ( move.l [ps]+,[dp]+ )
  21. : 4* ( n -- n*4 ) 2* 2* ; macro
  22. : 8* ( n -- n*8 ) 4* 2* ;
  23. : R+ ( n -- n+r ) ( add the loop index to the number on the stack )
  24.     ,$ 3017 ,$ D156 ; macro  ( move.w [rs],d0 add.w d0,[ps] )
  25. : 2R ( -- d ) ( rstack: d -- d ) ,$ 2D17 ; macro  ( move.l [rs],-[ps] )
  26.  
  27. ( time stuff )
  28. variable TLAST  0 tlast !  ( timer )
  29. 10 constant DELAY
  30. : TICKS ( -- n ) 364 0 l@ ;  ( ticks since reference time )
  31. : TIME ( -- ) ( wait for "delay" number of ticks )
  32.     ticks tlast !
  33.     BEGIN  ticks tlast @ - abs delay >  UNTIL ;
  34.  
  35. ( random numbers )
  36. \ Pick a random number from 0 to n
  37. : SEED ( -- daddr ) ,$ 2d15 126 0 dnegate d+ ;
  38. : RANDOMIZE 524 0 dl@  seed dl! ;
  39. : RANDOM ( n -- n' )
  40.     0 >r ,$ A861  r> ( _Random )
  41.     swap 32768 */ abs ;  ( scale to size from stack )
  42. : 0TO4 ( -- n ) 5 random ;
  43.  
  44. ( pick 5 of each )
  45. variable OFEACH 6 allot  ( how many cards of each type )
  46. : OFTHIS ( n -- addr ) ofeach + ;
  47. : @THIS ( n -- n' ) ofthis c@ ;
  48. : DNEW ( -- ) randomize  5 0 DO 5 ofeach r + c! LOOP ;
  49. : PICK ( -- n )
  50.     0to4 dup @this IF
  51.       dup @this 1- over ofthis c!
  52.     ELSE drop pick THEN ;
  53.  
  54. ( fill the deck with 5 of each )
  55. variable CARD  ( the current card number )
  56. variable DECK 24 allot  deck 26 0 fill
  57. : SHUFFLE ( -- ) dnew 25 0 DO pick deck r + c! LOOP ;
  58.  
  59. ( rectangles )
  60. : RECT ( compile: -- ) ( run: -- addr ) variable 6 allot ;
  61. : !RECT ( t l b r rect -- ) >r  swap r 4 + 2!  swap r> 2! ;
  62. : RERASE ( rect -- ) a>r ,$ A8A3 ;  ( _EraseRect )
  63. : RRFRAME ( cornerh cornerv rect -- )
  64.     a>r 2>r ,$ A8B0 ;  ( _FrameRoundRect )
  65. : RRERASE ( cornerh cornerv rect -- )
  66.     a>r 2>r ,$ A8B2 ;  ( _EraseRoundRect )
  67. : RLGRAY ( rect -- ) magenta a>r ( paint a rect gray )
  68.      ,$ 2055  ( movea.l [a5],a0 )
  69.      ,$ 4868 ,$ FFE0  ( pea -32[a0] )
  70.      ,$ A8A5 ;  ( _PaintRect )
  71. : ?IN ( h v rect -- flag ) ( true if h,v is in rect at addr )
  72.     0 >r  rot rot 2>r  a>r  ,$ A8AD r> ;  ( _PtInRect )
  73.  
  74. ( fonts )
  75. : !FONT ( n -- ) >r ,$ A887 ; macro  ( _TextFont ) ( set font )
  76. : !FSIZE ( n -- ) >r ,$ A88A ; macro  ( _TextSize ) ( set size )
  77. : !FFACE ( n -- ) >r ,$ A888 ; macro  ( _TextFace ) ( set face )
  78. : BFONT ( -- ) 3 !font  9 !fsize  1 !fface ;  ( set a little bold font )
  79. : LFONT ( -- ) 3 !font  9 !fsize  0 !fface ;
  80. : CFONT ( -- ) 3 !font  9 !fsize  32 !fface ;
  81.  
  82. ( pictures )
  83. : GETPICT ( id -- dhandle ) 0 0 2>r  >r  ,$ A9BC  2r> ;  ( _GetPict )
  84. : PDRAW ( rect dhandle -- ) ( draw a picture in a rect )
  85.     2>r a>r ,$ A8F6 ;  ( _DrawPicture )
  86.  
  87. ( the rects:  T   L   B   R )
  88. rect CRECT     3   4 157 113  crect !rect  ( card rect )
  89. rect CTRECT    4 117 157 209 ctrect !rect  ( control rect )
  90. rect LCRECT  160   4 209 209 lcrect !rect  ( little card rect )
  91. rect CORECT   12 121  77 204 corect !rect  ( stats group )
  92. rect GURECT  104 121 117 204 gurect !rect  ( show stats button rect )
  93. rect TGRECT  136 121 149 204 tgrect !rect  ( about button rect )
  94. rect SCRECT  120 121 133 204 screct !rect  ( show cards button rect )
  95. rect SHRECT   88 121 101 204 shrect !rect  ( reset button rect rect )
  96.  
  97. create LCRECTS ( the Little Card button rects )
  98.     163 ,   8 , 206 ,  42 ,  ( little circle )
  99.     163 ,  48 , 206 ,  82 ,  ( little cross  )
  100.     163 ,  88 , 206 , 122 ,  ( little waves  )
  101.     163 , 128 , 206 , 162 ,  ( little square )
  102.     163 , 168 , 206 , 202 ,  ( little star   )
  103. : LCBRECT ( n -- addr ) 8* lcrects + ;  ( get addr of button rect ) 
  104.  
  105. ( card pictures )
  106. create CARDS  24 allot ( an array of picture handles )
  107. : !CARDS ( -- ) ( fill cards array )
  108.     6 0 DO
  109.       myid r+ getpict  ( get a picture handle for PICT id+0 to id+5 )
  110.       cards r 4* + 2!  ( stash the picture handles in 'cards' )
  111.     LOOP ;
  112.  
  113. 2variable LCARD  ( pict handle of the last card )
  114. : !NC ( -- ) cards 20 + 2@  lcard 2! ; ( last card = noncard )
  115.  
  116. ( draw the parts of the window )
  117. : CHIDE ( -- ) ( draw the hidden card )
  118.     crect cards 20 + 2@ pdraw ;
  119. : .CARD ( n -- ) ( draw the "n"th card )
  120.     crect swap 4* cards + 2@  ( get the pict handle )
  121.     2dup lcard 2!  ( store pict handle into lcard )
  122.     pdraw  time chide ;
  123. : .BUTT ( n -- ) ( draw the "n"th button )
  124.     dup 0< 0= IF  ( negative is no card )
  125.     dup  lcbrect swap ( the button's rect )
  126.     6 +  ( the button pictures start at #7 )
  127.     myid + getpict pdraw THEN ;  ( get and draw it )
  128. : BSHOW ( -- ) 5 0 DO  r .butt loop ;  ( draw the buttons )
  129.  
  130. : HV>CARD ( h v -- card# )
  131.     -1 rot rot  5 0 DO
  132.       2dup  r lcbrect  ?in IF
  133.         rot drop r  rot rot 
  134.     THEN LOOP 2drop ;
  135.  
  136. variable RIGHT  0 right !
  137. variable TRIES  0 tries !
  138. : .RIGHT  right @ . ;
  139. : .TRIES  tries @ . ;
  140. : .RANK  right @ 100 tries @ */ 5 *  ( percent * 5 )
  141.     dup 0< IF drop 0 THEN  . ;  ( correct for /0, print it )
  142.  
  143. variable BDTEXT
  144. : .HIDE ( -- ) black 133 130 !pen ." Hide Cards" ;
  145. : .SHOW ( -- ) black 133 130 !pen ." Show Cards" ;
  146. ' .hide bdtext !
  147.  
  148. variable BDSTATS
  149. : .SHIDE ( -- ) black 133 114 !pen ." Show Stats" ;
  150. : .SSHOW ( -- ) black 133 114 !pen ." Hide Stats" ;
  151. ' .sshow bdstats !
  152.  
  153. : BDRAW ( -- ) ( draw the control buttons )
  154.     bfont
  155.     10 10 tgrect rrerase
  156.     black 133 146 !pen  ." Last Card"
  157.     blue 10 10 tgrect rrframe  ( draw a button )
  158.     10 10 gurect rrerase
  159.       bdstats @ execute  ( draw the Hide/Stats button text )
  160.     blue 10 10 gurect rrframe  ( draw a button )
  161.     10 10 screct rrerase
  162.       bdtext @ execute  ( draw the Hide/Show button text )
  163.     blue 10 10 screct rrframe  ( draw a button )
  164.     10 10 shrect rrerase
  165.     black  133 98 !pen  ." Reset Stats"
  166.     blue 10 10 shrect rrframe ;  ( draw a button )
  167.  
  168. variable FFLAG -1 fflag !
  169. : FDRAW ( -- ) ( draw the information fields )
  170.     fflag @ IF  bfont 
  171.       10 10 corect rrerase
  172.       blue 10 10 corect rrframe  black ( draw 'stats' field )
  173.       125 23 !pen  ."   Statistics"
  174.       125 35 !pen  ." Right:" .right
  175.       125 47 !pen  ." Given:" .tries
  176.       125 59 !pen  ." Rank:" .rank ." %"
  177.       124 72 !pen cfont ." © '88-'93 C.Heilman"
  178.     ELSE
  179.       magenta corect rlgray  ( fill background rect )
  180.     THEN ;
  181. : DOFHIT ( -- ) ( handle show stats button )
  182.     fflag @ dup 0= fflag !
  183.     IF [ ' .shide literal ] bdstats !  
  184.     ELSE [ ' .sshow literal ] bdstats ! THEN
  185.     bdraw  fdraw ;
  186.  
  187. variable DOCDRAW  ' .card docdraw !
  188. : HIDE ( -- )  chide  !nc
  189.     [ ' .show literal ] bdtext !
  190.     [ ' drop literal ] docdraw !  bdraw ;
  191. : SHOW ( -- )
  192.     [ ' .hide literal ] bdtext !
  193.     [ ' .card literal ] docdraw !  bdraw ;
  194. : HBUTT ( -- ) ( do hide button )
  195.     docdraw @ [ ' .card literal ] = IF
  196.       hide ELSE show THEN ;
  197.  
  198. : CBUTT ( n -- ) ( handle click in button for card n )
  199.     card @  deck + c@  ( get the next card from the deck )
  200.     dup rot = IF  ( if it is a correct guess )
  201.       1 right +! THEN  ( increment 'right' )
  202.     1 tries +!  1 card +!  ( increment 'tries' and 'card' )
  203.     right @ 10000 mod right !  ( bound on right )
  204.     tries @ 10000 mod dup tries !  ( bound on tries )
  205.     0= IF 0 right ! THEN
  206.     docdraw @ execute  ( display the card for a 'time' )
  207.     fdraw  ( draw new stats )
  208.     card @ 25 = IF  ( if it is the end of the deck )
  209.       shuffle  0 card ! THEN ;  ( shuffle the deck )
  210.  
  211. : DOABOUT ( -- ) ( display an alert box )
  212.     0 >r  myid >r  0 0 2>r  ,$ A985  r> drop ;  ( _Alert )
  213.  
  214. : LCSHOW ( -- ) ( show the last card for 2X time )
  215.     crect  lcard 2@ pdraw
  216.     BEGIN ?button 0= UNTIL chide ;
  217.  
  218. : BUTTON ( -- ) ( button handler )
  219.     @mouse 2>r  ( stash mouse coords on rstack )
  220.     2r hv>card dup 0< 0= IF  ( if it is in a card button )
  221.       cbutt  ( handle the card button )
  222.     ELSE drop  ( drop the -1 flag )
  223.       2r shrect ?in IF  ( in reset button )
  224.         0 card !  0 right !  0 tries !  ( reset variables )
  225.         shuffle  fdraw  bdraw  !nc  ( shuffle, draw stats & buttons )
  226.       ELSE  ( not in reset )
  227.         2r screct ?in IF  ( in show/hide button? )
  228.           hbutt  ( handle show/hide button )
  229.         ELSE  ( not in show/hide button )
  230.           2r tgrect ?in IF  ( in last card button )
  231.             lcshow
  232.           ELSE  ( not in about button )
  233.             2r gurect ?in IF  ( handle show stats button )
  234.               dofhit
  235.             ELSE beep  ( not in a button )
  236.             THEN
  237.           THEN
  238.         THEN
  239.       THEN
  240.     THEN  2r> 2drop ;  ( drop the coords from the rstack )
  241.  
  242. : WDRAW ( -- ) ( draw the window )
  243.     magenta 4 +md rlgray  ( fill background rect )
  244.     cyan 14 14 lcrect rrframe  ( draw little card rect )
  245.     cyan 14 14 ctrect rrframe  ( draw control rect )
  246.     fdraw  bdraw  chide  bshow -100 -100 !pen ;
  247.  
  248. : START ( -- )  !cards 
  249.     0 card !  0 right !  0 tries !  shuffle  !nc
  250.     BEGIN key drop AGAIN ;
  251.  
  252. 214 212 8 +md 2!  ( set window size )
  253. ' button  16 +md ! ( button handler )
  254. ' wdraw  14 +md !  ( update handler )
  255. ' start  26 +md !  ( startup handler )
  256. ' null  18 +md @ 2+ @ 8 + !  ( paste handler )
  257. 22 +md @  18 +md @ @ !  ( quit handler )
  258. ' doabout  24 +md !  ( about handler )
  259.  
  260. save bye
  261.